home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / kcl.lha / c / array.c < prev    next >
C/C++ Source or Header  |  1987-06-04  |  18KB  |  860 lines
  1. /*
  2. (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  3. Copying of this file is authorized to users who have executed the true and
  4. proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  5. */
  6.  
  7. /*
  8.     array.c
  9.  
  10.     array routines
  11. */
  12.  
  13. #include "include.h"
  14.  
  15. #define    ADIMLIM        16*1024*1024
  16. #define    ATOTLIM        16*1024*1024
  17.  
  18.  
  19. enum aelttype
  20. get_aelttype(x)
  21. object x;
  22. {
  23.     if (x == Sstring_char)
  24.         return(aet_ch);
  25.     else if (x == Sbit)
  26.         return(aet_bit);
  27.     else if (x == Sfixnum)
  28.         return(aet_fix);
  29.     else if (x == Sshort_float)
  30.         return(aet_sf);
  31.     else if (x == Slong_float)
  32.         return(aet_lf);
  33.     else
  34.         return(aet_object);
  35. }
  36.  
  37. enum aelttype
  38. array_elttype(x)
  39. object x;
  40. {
  41.     switch(type_of(x)) {
  42.     case t_array:
  43.     case t_vector:
  44.         return((enum aelttype)x->a.a_elttype);
  45.  
  46.     case t_string:
  47.         return(aet_ch);
  48.  
  49.     case t_bitvector:
  50.         return(aet_bit);
  51.  
  52.     default:
  53.         FEwrong_type_argument(Sarray, x);
  54.     }
  55. }
  56.  
  57. char *
  58. array_address(x, inc)
  59. object x;
  60. int inc;
  61. {
  62.     switch(array_elttype(x)) {
  63.     case aet_object:
  64.     case aet_fix:
  65.     case aet_sf:
  66.         return((char *)(x->a.a_self + inc));
  67.  
  68.     case aet_ch:
  69.         return(x->st.st_self + inc);
  70.  
  71.     case aet_lf:
  72.         return((char *)(x->lfa.lfa_self + inc));
  73.     }
  74. }
  75.  
  76. array_allocself(x, staticp)
  77. object x;
  78. bool staticp;
  79. {
  80.     int i, d;
  81.     char *(*f)();
  82.  
  83.     d = x->a.a_dim;
  84.     if (staticp)
  85.         f = alloc_contblock;
  86.     else
  87.         f = alloc_relblock;
  88.     switch (array_elttype(x)) {
  89.     case aet_object:
  90.         x->a.a_self = (object *)(*f)(sizeof(object)*d);
  91.         for (i = 0;  i < d;  i++)
  92.             x->a.a_self[i] = Cnil;
  93.         break;
  94.  
  95.     case aet_ch:
  96.         x->st.st_self = (*f)(d);
  97.         for (i = 0;  i < d;  i++)
  98.             x->st.st_self[i] = ' ';
  99.         break;
  100.  
  101.     case aet_bit:
  102.         d = (d+7)/8;
  103.         x->bv.bv_self = (*f)(d);
  104.         for (i = 0;  i < d;  i++)
  105.             x->bv.bv_self[i] = '\0';
  106.         x->bv.bv_offset = 0;
  107.         break;
  108.  
  109.     case aet_fix:
  110.         x->fixa.fixa_self = (fixnum *)(*f)(sizeof(fixnum)*d);
  111.         for (i = 0;  i < d;  i++)
  112.             x->fixa.fixa_self[i] = 0;
  113.         break;
  114.  
  115.     case aet_sf:
  116.         x->sfa.sfa_self = (shortfloat *)(*f)(sizeof(shortfloat)*d);
  117.         for (i = 0;  i < d;  i++)
  118.             x->sfa.sfa_self[i] = 0.0;
  119.         break;
  120.  
  121.     case aet_lf:
  122.         x->lfa.lfa_self = (longfloat *)(*f)(sizeof(longfloat)*d);
  123.         for (i = 0;  i < d;  i++)
  124.             x->lfa.lfa_self[i] = 0.0;
  125.         break;
  126.     }
  127. }
  128.  
  129. object
  130. aref(x, index)
  131. object x;
  132. int index;
  133. {
  134.     if (index >= x->a.a_dim) {
  135.         vs_push(make_fixnum(index));
  136.         FEerror("The index, ~D, is too large.", 1, vs_head);
  137.     }
  138.     switch (array_elttype(x)) {
  139.     case aet_object:
  140.         return(x->a.a_self[index]);
  141.  
  142.     case aet_ch:
  143.         return(code_char(x->ust.ust_self[index]));
  144.  
  145.     case aet_bit:
  146.         index += x->bv.bv_offset;
  147.         if (x->bv.bv_self[index/8] & (0200>>index%8))
  148.             return(small_fixnum(1));
  149.         else
  150.             return(small_fixnum(0));
  151.  
  152.     case aet_fix:
  153.         return(make_fixnum(x->fixa.fixa_self[index]));
  154.  
  155.     case aet_sf:
  156.         return(make_shortfloat(x->sfa.sfa_self[index]));
  157.  
  158.     case aet_lf:
  159.         return(make_longfloat(x->lfa.lfa_self[index]));
  160.     }
  161. }
  162.  
  163. object
  164. aset(x, index, value)
  165. object x;
  166. int index;
  167. object value;
  168. {
  169.     int i;
  170.  
  171.     if (index >= x->a.a_dim) {
  172.         vs_push(make_fixnum(index));
  173.         FEerror("The index, ~D, too large.", 1, vs_head);
  174.     }
  175.     switch (array_elttype(x)) {
  176.     case aet_object:
  177.         x->a.a_self[index] = value;
  178.         break;
  179.  
  180.     case aet_ch:
  181.         if (type_of(value) != t_character)
  182.             FEerror("~S is not a character.", 1, value);
  183.         x->st.st_self[index] = value->ch.ch_code;
  184.         break;
  185.  
  186.     case aet_bit:
  187.         i = fixint(value);
  188.         if (i != 0 && i != 1)
  189.             FEerror("~S is not a bit.", 1, value);
  190.         index += x->bv.bv_offset;
  191.         if (i == 0)
  192.             x->bv.bv_self[index/8] &= ~(0200>>index%8);
  193.         else
  194.             x->bv.bv_self[index/8] |= 0200>>index%8;
  195.         break;
  196.  
  197.     case aet_fix:
  198.         x->fixa.fixa_self[index] = fixint(value);
  199.         break;
  200.  
  201.     case aet_sf:
  202.         x->sfa.sfa_self[index] = object_to_double(value);
  203.         break;
  204.  
  205.     case aet_lf:
  206.         x->lfa.lfa_self[index] = object_to_double(value);
  207.         break;
  208.     }
  209.     return(value);
  210. }
  211.  
  212. object
  213. aref1(v, index)
  214. object v;
  215. int index;
  216. {
  217.     int i;
  218.     object l;
  219.  
  220.     if (index < 0) {
  221.         vs_push(make_fixnum(index));
  222.         FEerror("Negative index: ~D.", 1, vs_head);
  223.     }
  224.     switch (type_of(v)) {
  225.     case t_vector:
  226.     case t_bitvector:
  227.         return(aref(v, index));
  228.  
  229.     case t_string:
  230.         if (index >= v->st.st_dim)
  231.             goto E;
  232.         return(code_char(v->ust.ust_self[index]));
  233.  
  234.     default:
  235.         FEerror("~S is not a vector.", 1, v);
  236.     }
  237.  
  238. E:
  239.     vs_push(make_fixnum(index));
  240.     FEerror("The index, ~D, is too large.", 1, vs_head);
  241. }
  242.  
  243. object
  244. aset1(v, index, val)
  245. object v;
  246. int index;
  247. object val;
  248. {
  249.     int i;
  250.     object l;
  251.  
  252.     if (index < 0) {
  253.         vs_push(make_fixnum(index));
  254.         FEerror("Negative index: ~D.", 1, vs_head);
  255.     }
  256.     switch (type_of(v)) {
  257.     case t_vector:
  258.     case t_bitvector:
  259.         return(aset(v, index, val));
  260.  
  261.     case t_string:
  262.         if (index >= v->st.st_dim)
  263.             goto E;
  264.         if (type_of(val) != t_character)
  265.             FEerror("~S is not a character.", 1, val);
  266.         v->st.st_self[index] = val->ch.ch_code;
  267.         return(val);
  268.  
  269.     default:
  270.         FEerror("~S is not a vector.", 1, v);
  271.     }
  272.  
  273. E:
  274.     vs_push(make_fixnum(index));
  275.     FEerror("The index, ~D, is too large", 1, vs_head);
  276. }
  277.  
  278. /*
  279.     Displace(from, to, offset) displaces the from-array
  280.     to the to-array (the original array) by the specified offset.
  281.     It changes the a_displaced field of both arrays.
  282.     The field is a cons; the car of the from-array points to
  283.     the to-array and the cdr of the to-array is a list of arrays
  284.     displaced to the to-array, so the from-array is pushed to the
  285.     cdr of the to-array's a_displaced.
  286. */
  287. displace(from, to, offset)
  288. object from, to, offset;
  289. {
  290.     int j;
  291.     enum aelttype totype, fromtype;
  292.  
  293.     j = fixnnint(offset);
  294.     totype = array_elttype(to);
  295.     fromtype = array_elttype(from);
  296.     if (totype != fromtype)
  297.         FEerror("Cannot displace the array,~%\
  298. because the element types don't match.", 0);
  299.     if (j + from->a.a_dim > to->a.a_dim)
  300.         FEerror("Cannot displace the array,~%\
  301. because the total size of the to-array is too small.", 0);
  302.     from->a.a_displaced = make_cons(to, Cnil);
  303.     if (to->a.a_displaced == Cnil)
  304.         to->a.a_displaced = make_cons(Cnil, Cnil);
  305.     to->a.a_displaced->c.c_cdr =
  306.     make_cons(from, to->a.a_displaced->c.c_cdr);
  307.     if (fromtype == aet_bit) {
  308.         j += to->bv.bv_offset;
  309.         from->bv.bv_self = to->bv.bv_self + j/8;
  310.         from->bv.bv_offset = j%8;
  311.     }
  312. #ifdef MV
  313.  
  314.  
  315. #endif
  316.     else
  317.         from->st.st_self = array_address(to, j);
  318. }
  319.  
  320. /*
  321.     Undisplace(from) destroys the displacement from the from-array.
  322. */
  323. undisplace(from)
  324. object from;
  325. {
  326.     object *p;
  327.     object to = from->a.a_displaced->c.c_car;
  328.  
  329.     if (to == Cnil)
  330.         return;
  331.     from->a.a_displaced->c.c_car = Cnil;
  332.     for (p = &(to->a.a_displaced->c.c_cdr);;  p = &((*p)->c.c_cdr))
  333.         if ((*p)->c.c_car == from) {
  334.             *p = (*p)->c.c_cdr;
  335.             return;
  336.         }
  337. }
  338.  
  339. /*
  340.     Check_displaced(dlist, orig, newdim) checks if the displaced
  341.     arrays can keep the displacement when the original array is
  342.     adjusted.
  343.     Dlist is the list of displaced arrays, orig is the original array
  344.     and newdim is the new dimension of the original array.
  345. */
  346. check_displaced(dlist, orig, newdim)
  347. object dlist, orig;
  348. int newdim;
  349. {
  350.     object x;
  351.  
  352.     for (;  dlist != Cnil;  dlist = dlist->c.c_cdr) {
  353.         x = dlist->c.c_car;
  354.         if (x->a.a_self == NULL)
  355.             continue;
  356.         if (array_elttype(x) != aet_bit) {
  357.             if (array_address(x, x->a.a_dim) >
  358.                 array_address(orig, newdim))
  359.                 FEerror("Can't keep displacement.", 0);
  360.         } else {
  361.             if ((x->bv.bv_self - orig->bv.bv_self)*8 +
  362.                 x->bv.bv_dim - newdim +
  363.                 x->bv.bv_offset - orig->bv.bv_offset > 0)
  364.                 FEerror("Can't keep displacement.", 0);
  365.         }
  366.         check_displaced(x->a.a_displaced->c.c_cdr, orig, newdim);
  367.     }
  368. }
  369.  
  370. /*
  371.     Adjust_displaced(x, diff) adds the int value diff
  372.     to the a_self field of the array x and all the arrays displaced to x.
  373.     This function is used in siLreplace_array (ADJUST-ARRAY) and
  374.     the garbage collector.
  375. */
  376. adjust_displaced(x, diff)
  377. object x;
  378. int diff;
  379. {
  380.     if (x->a.a_self != NULL)
  381.         x->a.a_self = (object *)((int)(x->a.a_self) + diff);
  382.     for (x = x->a.a_displaced->c.c_cdr;  x != Cnil;  x = x->c.c_cdr)
  383.         adjust_displaced(x->c.c_car, diff);
  384. }
  385.  
  386. setup_fillp(x, fillp)
  387. object x, fillp;
  388. {
  389.     int j;
  390.  
  391.     if (fillp == Cnil) {
  392.         x->v.v_hasfillp = FALSE;
  393.         x->v.v_fillp = x->v.v_dim;
  394.     } else if (fillp == Ct) {
  395.         x->v.v_hasfillp = TRUE;
  396.         x->v.v_fillp = x->v.v_dim;
  397.     } else if ((j = fixnnint(fillp)) > x->v.v_dim)
  398.         FEerror("The fill-pointer ~S is too large.", 1, fillp);
  399.     else {
  400.         x->v.v_hasfillp = TRUE;
  401.         x->v.v_fillp = j;
  402.     }
  403. }
  404.  
  405. /*
  406.     Internal function for making arrays:
  407.  
  408.         (si:make-pure-array element-type adjustable
  409.                         displaced-to displaced-index-offset
  410.                     static
  411.                         dim0 dim1 ... )
  412. */
  413. siLmake_pure_array()
  414. {
  415.     int r, s, i, j;
  416.     object x;
  417.  
  418.     r = vs_top - vs_base - 5;
  419.     if (r < 0)
  420.         too_few_arguments();
  421.     x = alloc_object(t_array);
  422.     x->a.a_self = NULL;
  423.     x->a.a_displaced = Cnil;
  424.     x->a.a_rank = r;
  425.     x->a.a_dims = NULL;
  426.     x->a.a_elttype = (short)get_aelttype(vs_base[0]);
  427.     vs_base[0] = x;
  428.     x->a.a_dims = (int *)alloc_relblock(sizeof(int)*r);
  429.     if (r >= ARANKLIM) {
  430.         vs_push(make_fixnum(r));
  431.         FEerror("The array rank, ~R, is too large.", 1, vs_head);
  432.     }
  433.     for (i = 0, s = 1;  i < r;  i++) {
  434.         if ((j = fixnnint(vs_base[i+5])) > ADIMLIM) {
  435.             vs_push(make_fixnum(i+1));
  436.             FEerror("The ~:R array dimension, ~D, is too large.",
  437.                 2, vs_head, vs_base[i+5]);
  438.         }
  439.         s *= (x->a.a_dims[i] = j);
  440.     }
  441.     if (s > ATOTLIM) {
  442.         vs_push(make_fixnum(s));
  443.         FEerror("The array total size, ~D, is too large.",
  444.             1, vs_head);
  445.     }
  446.     x->a.a_dim = s;
  447.     x->a.a_adjustable = vs_base[1] != Cnil;
  448.     if (vs_base[2] == Cnil)
  449.         array_allocself(x, vs_base[4] != Cnil);
  450.     else
  451.         displace(x, vs_base[2], vs_base[3]);
  452.     vs_top = vs_base + 1;
  453. }
  454.  
  455. /*
  456.     Internal function for making vectors:
  457.  
  458.         (si:make-vector element-type dimension adjustable fill-pointer
  459.                 displaced-to displaced-index-offset
  460.                     static)
  461. */
  462. siLmake_vector()
  463. {
  464.     int d, i, j;
  465.     object x;
  466.     enum aelttype aet;
  467.  
  468.     check_arg(7);
  469.     aet = get_aelttype(vs_base[0]);
  470.     if ((d = fixnnint(vs_base[1])) > ADIMLIM)
  471.         FEerror("The vector dimension, ~D, is too large.",
  472.             1, vs_base[1]);
  473.     if (aet == aet_ch)
  474.         x = alloc_object(t_string);
  475.     else if (aet == aet_bit)
  476.         x = alloc_object(t_bitvector);
  477.     else
  478.         x = alloc_object(t_vector);
  479.     x->v.v_self = NULL;
  480.     x->v.v_displaced = Cnil;
  481.     x->v.v_dim = d;
  482.     x->v.v_adjustable = vs_base[2] != Cnil;
  483.     if (aet != aet_ch && aet != aet_bit)
  484.         x->v.v_elttype = (short)aet;
  485.     vs_base[0] = x;
  486.     setup_fillp(x, vs_base[3]);
  487.     if (vs_base[4] == Cnil)
  488.         array_allocself(x, vs_base[6] != Cnil);
  489.     else
  490.         displace(x, vs_base[4], vs_base[5]);
  491.     vs_top = vs_base + 1;
  492. }
  493.  
  494. Laref()
  495. {
  496.     int r, s, i, j;
  497.     object x;
  498.  
  499.     r = vs_top - vs_base - 1;
  500.     if (r < 0)
  501.         too_few_arguments();
  502.     x = vs_base[0];
  503.     switch (type_of(x)) {
  504.     case t_array:
  505.         if (r != x->a.a_rank)
  506.             FEerror("Wrong number of indices.", 0);
  507.         for (i = j = 0;  i < r;  i++) {
  508.             if ((s = fixnnint(vs_base[i+1])) >= x->a.a_dims[i]) {
  509.                 vs_push(make_fixnum(i+1));
  510.                 FEerror("The ~:R index, ~S, to the array~%\
  511. ~S is too large.", 3, vs_head, vs_base[i+1], x);
  512.             }
  513.             j = j*(x->a.a_dims[i]) + s;
  514.         }
  515.         break;
  516.  
  517.     case t_vector:
  518.     case t_string:
  519.     case t_bitvector:
  520.         if (r != 1)
  521.             FEerror("Wrong number of indices.", 0);
  522.         j = fixnnint(vs_base[1]);
  523.         if (j >= x->v.v_dim) {
  524.             FEerror("The first index, ~S, to the array~%\
  525. ~S is too large.", 2, vs_base[1], x);
  526.         }
  527.         break;
  528.  
  529.     default:
  530.         FEwrong_type_argument(Sarray, x);
  531.     }
  532.     vs_base[0] = aref(x, j);
  533.     vs_top = vs_base + 1;
  534. }
  535.  
  536. /*
  537.     Internal function for setting array elements:
  538.  
  539.         (si:aset array dim0 dim1 ... newvalue)
  540. */
  541. siLaset()
  542. {
  543.     int r, s, i, j;
  544.     object x;
  545.  
  546.     r = vs_top - vs_base - 2;
  547.     if (r < 0)
  548.         too_few_arguments();
  549.     x = vs_base[0];
  550.     switch (type_of(x)) {
  551.     case t_array:
  552.         if (r != x->a.a_rank)
  553.             FEerror("Wrong number of indices.", 0);
  554.         for (i = j = 0;  i < r;  i++) {
  555.             if ((s = fixnnint(vs_base[i+1])) >= x->a.a_dims[i]) {
  556.                 vs_push(make_fixnum(i+1));
  557.                 FEerror("The ~:R index, ~S, to the array~%\
  558. ~S is too large.", 3, vs_head, vs_base[i+1], x);
  559.             }
  560.             j = j*(x->a.a_dims[i]) + s;
  561.         }
  562.         break;
  563.  
  564.     case t_vector:
  565.     case t_string:
  566.     case t_bitvector:
  567.         if (r != 1)
  568.             FEerror("Wrong number of indices.", 0);
  569.         j = fixnnint(vs_base[1]);
  570.         if (j >= x->v.v_dim) {
  571.             FEerror("The first index, ~S, to the array~%\
  572. ~S is too large.", 2, vs_base[1], x);
  573.         }
  574.         break;
  575.  
  576.     default:
  577.         FEwrong_type_argument(Sarray, x);
  578.     }
  579.     aset(x, j, vs_base[r+1]);
  580.     vs_base[0] = vs_base[r+1];
  581.     vs_top = vs_base + 1;
  582. }
  583.  
  584. Larray_element_type()
  585. {
  586.     check_arg(1);
  587.  
  588.     switch (array_elttype(vs_base[0])) {
  589.     case aet_object:
  590.         vs_base[0] = Ct;
  591.         break;
  592.  
  593.     case aet_ch:
  594.         vs_base[0] = Sstring_char;
  595.         break;
  596.  
  597.     case aet_bit:
  598.         vs_base[0] = Sbit;
  599.         break;
  600.  
  601.     case aet_fix:
  602.         vs_base[0] = Sfixnum;
  603.         break;
  604.  
  605.     case aet_sf:
  606.         vs_base[0] = Sshort_float;
  607.         break;
  608.  
  609.     case aet_lf:
  610.         vs_base[0] = Slong_float;
  611.         break;
  612.     }
  613. }
  614.  
  615. Larray_rank()
  616. {
  617.     check_arg(1);
  618.     check_type_array(&vs_base[0]);
  619.     if (type_of(vs_base[0]) == t_array)
  620.         vs_base[0] = make_fixnum(vs_base[0]->a.a_rank);
  621.     else
  622.         vs_base[0] = make_fixnum(1);
  623. }
  624.  
  625. Larray_dimension()
  626. {
  627.     int i;
  628.  
  629.     check_arg(2);
  630.     check_type_array(&vs_base[0]);
  631.     i = fixnnint(vs_base[1]);
  632.     if (type_of(vs_base[0]) == t_array) {
  633.         if (i >= vs_base[0]->a.a_rank)
  634.             goto ILLEGAL;
  635.         vs_base[0] = make_fixnum(vs_base[0]->a.a_dims[i]);
  636.     } else {
  637.         if (i != 0)
  638.             goto ILLEGAL;
  639.         vs_base[0] = make_fixnum(vs_base[0]->v.v_dim);
  640.     }
  641.     vs_top = vs_base + 1;
  642.     return;
  643.  
  644. ILLEGAL:
  645.     FEerror("~S is an illegal axis-number to the array~%\
  646. ~S.", 2, vs_base[1], vs_base[0]);
  647.  
  648. }
  649.  
  650. Larray_total_size()
  651. {
  652.     check_arg(1);
  653.     check_type_array(&vs_base[0]);
  654.     vs_base[0] = make_fixnum(vs_base[0]->a.a_dim);
  655. }
  656.  
  657. Ladjustable_array_p()
  658. {
  659.     check_arg(1);
  660.     check_type_array(&vs_base[0]);
  661.     if (vs_base[0]->a.a_adjustable)
  662.         vs_base[0] = Ct;
  663.     else
  664.         vs_base[0] = Cnil;
  665. }
  666.  
  667. /*
  668.     Internal function for checking if an array is displaced.
  669. */
  670. siLdisplaced_array_p()
  671. {
  672.     check_arg(1);
  673.     check_type_array(&vs_base[0]);
  674.     if (vs_base[0]->a.a_displaced->c.c_car != Cnil)
  675.         vs_base[0] = Ct;
  676.     else
  677.         vs_base[0] = Cnil;
  678. }
  679.  
  680. Lsvref()
  681. {
  682.     int i;
  683.     object x;
  684.  
  685.     check_arg(2);
  686.     x = vs_base[0];
  687.     if (type_of(x) != t_vector ||
  688.         x->v.v_adjustable ||
  689.         x->v.v_hasfillp ||
  690.         x->v.v_displaced->c.c_car != Cnil ||
  691.         (enum aelttype)x->v.v_elttype != aet_object)
  692.         FEerror("~S is not a simple general vector.", 1, x);
  693.     if ((i = fix(vs_base[1])) >= x->v.v_dim)
  694.         illegal_index(x, vs_base[1]);
  695.     vs_base[0] = x->v.v_self[i];
  696.     vs_pop;
  697. }
  698.  
  699. siLsvset()
  700. {
  701.     int i;
  702.     object x;
  703.  
  704.     check_arg(3);
  705.     x = vs_base[0];
  706.     if (type_of(x) != t_vector ||
  707.         x->v.v_adjustable ||
  708.         x->v.v_hasfillp ||
  709.         x->v.v_displaced->c.c_car != Cnil ||
  710.         (enum aelttype)x->v.v_elttype != aet_object)
  711.         FEerror("~S is not a simple general vector.", 1, x);
  712.     if ((i = fixnnint(vs_base[1])) >= x->v.v_dim)
  713.         illegal_index(x, vs_base[1]);
  714.     vs_base[0] = x->v.v_self[i] = vs_base[2];
  715.     vs_pop;
  716.     vs_pop;
  717. }
  718.  
  719. Larray_has_fill_pointer_p()
  720. {
  721.     check_arg(1);
  722.     check_type_array(&vs_base[0]);
  723.     if (type_of(vs_base[0]) == t_array)
  724.         vs_base[0] = Cnil;
  725.     else if (vs_base[0]->v.v_hasfillp)
  726.         vs_base[0] = Ct;
  727.     else
  728.         vs_base[0] = Cnil;
  729. }
  730.  
  731. Lfill_pointer()
  732. {
  733.     check_arg(1);
  734.     check_type_vector(&vs_base[0]);
  735.     if (vs_base[0]->v.v_hasfillp)
  736.         vs_base[0] = make_fixnum(vs_base[0]->v.v_fillp);
  737.     else
  738.         FEerror("The vector ~S has no fill pointer.", 1, vs_base[0]);
  739. }
  740.  
  741. /*
  742.     Internal function for setting fill pointer.
  743. */
  744. siLfill_pointer_set()
  745. {
  746.     int i;
  747.  
  748.     check_arg(2);
  749.     check_type_vector(&vs_base[0]);
  750.     i = fixnnint(vs_base[1]);
  751.     if (vs_base[0]->v.v_hasfillp)
  752.         if (i > vs_base[0]->v.v_dim)
  753.             FEerror("The fill-pointer ~S is too large",
  754.                 1, vs_base[0]);
  755.         else
  756.             vs_base[0]->v.v_fillp = i;
  757.     else
  758.         FEerror("The vector ~S has no fill pointer.",
  759.             1, vs_base[0]);
  760.     vs_base[0] = vs_base[1];
  761.     vs_top = vs_base + 1;
  762. }
  763.  
  764. /*
  765.     Internal function for replacing the contents of arrays:
  766.  
  767.         (si:replace-array old-array new-array).
  768.  
  769.     Used in ADJUST-ARRAY.
  770. */
  771. siLreplace_array()
  772. {
  773.     object old, new, displaced, dlist;
  774.     int diff;
  775.  
  776.     check_arg(2);
  777.  
  778.     old = vs_base[0];
  779.     new = vs_base[1];
  780.     if (type_of(old) != type_of(new))
  781.         goto CANNOT;
  782.     if (type_of(old) == t_array && old->a.a_rank != new->a.a_rank)
  783.         goto CANNOT;
  784.     if (!old->a.a_adjustable)
  785.         FEerror("~S is not adjustable.", 1, old);
  786.     diff = (int)(new->a.a_self) - (int)(old->a.a_self);
  787.     dlist = old->a.a_displaced->c.c_cdr;
  788.     displaced = make_cons(new->a.a_displaced->c.c_car, dlist);
  789.     vs_push(displaced);
  790.     check_displaced(dlist, old, new->a.a_dim);
  791.     adjust_displaced(old, diff);
  792.     undisplace(old);
  793.     switch (type_of(old)) {
  794.     case t_array:
  795.     case t_vector:
  796.     case t_bitvector:
  797.         old->a = new->a;
  798.         break;
  799.  
  800.     case t_string:
  801.         old->st = new->st;
  802.         break;
  803.  
  804.     default:
  805.         goto CANNOT;
  806.     }
  807.     old->a.a_displaced = displaced;
  808.     vs_pop;
  809.     vs_pop;
  810.     return;
  811.  
  812. CANNOT:
  813.     FEerror("Cannot replace the array ~S~%\
  814. by the array ~S.", 2, old, new);
  815. }
  816.  
  817. siLaset_by_cursor()
  818. {
  819.     object *base = vs_base;
  820.     object x;
  821.  
  822.     check_arg(3);
  823.     vs_base = vs_top;
  824.     vs_push(base[0]);
  825.     for (x = base[2];  !endp(x);  x = MMcdr(x))
  826.         vs_push(MMcar(x));
  827.     vs_push(base[1]);
  828.     siLaset();
  829. }
  830.  
  831. init_array_function()
  832. {
  833.     make_constant("ARRAY-RANK-LIMIT", make_fixnum(ARANKLIM));
  834.     make_constant("ARRAY-DIMENSION-LIMIT", make_fixnum(ADIMLIM));
  835.     make_constant("ARRAY-TOTAL-SIZE-LIMIT", make_fixnum(ATOTLIM));
  836.  
  837.     make_si_function("MAKE-PURE-ARRAY", siLmake_pure_array);
  838.     make_si_function("MAKE-VECTOR", siLmake_vector);
  839.     make_function("AREF", Laref);
  840.     make_si_function("ASET", siLaset);
  841.     make_function("ARRAY-ELEMENT-TYPE", Larray_element_type);
  842.     make_function("ARRAY-RANK", Larray_rank);
  843.     make_function("ARRAY-DIMENSION", Larray_dimension);
  844.     make_function("ARRAY-TOTAL-SIZE", Larray_total_size);
  845.     make_function("ADJUSTABLE-ARRAY-P", Ladjustable_array_p);
  846.     make_si_function("DISPLACED-ARRAY-P", siLdisplaced_array_p);
  847.  
  848.     make_function("SVREF", Lsvref);
  849.     make_si_function("SVSET", siLsvset);
  850.  
  851.     make_function("ARRAY-HAS-FILL-POINTER-P",
  852.               Larray_has_fill_pointer_p);
  853.     make_function("FILL-POINTER", Lfill_pointer);
  854.     make_si_function("FILL-POINTER-SET", siLfill_pointer_set);
  855.  
  856.     make_si_function("REPLACE-ARRAY", siLreplace_array);
  857.  
  858.     make_si_function("ASET-BY-CURSOR", siLaset_by_cursor);
  859. }
  860.